module Salsa.Primitives where
import Salsa.Types
import Salsa.Parser
import Control.Monad.Error
import Text.XHtml.Frameset
import IO

-------------------------------------
-- Salsa Primitives
-------------------------------------

primitives :: [(String, [Exp] -> ThrowsError Exp)]
primitives = [("+", numOp (+)), ("-", numOp (-)), ("*", numOp (*)) 
              ,("/", numOp div), ("mod", binNumOp mod) 
              ,("quotient", binNumOp quot), ("remainder", binNumOp rem)
              ,("=",  compInt (==) ), ("<", compInt (<)) 
              ,(">", compInt (>)), ("<=", compInt (<=))
              ,(">=", compInt (>=)), ("/=", compInt (/=))
              ,("head", car), ("tail", cdr), ("cons", cons)
              ,("car", car), ("cdr", cdr), ("quote", quote')
              ,("string=?", compStr (==)), ("string<?", compStr (<))
              ,("string>?", compStr (>)), ("string<=?", compStr (<=))
              ,("string>=?", compStr (>=)), ("string/=?", compStr (/=))
              ,("eq?", eqv), ("eqv?", eqv), ("append", app), ("escape", escape), ("concat", conct)
              ,("symbol?", isSym), ("pair?", isPair), ("number?", isNum), ("string?", isStr)
              ,("boolean?", isBool), ("symbol->string", sym2str), ("string->symbol", str2sym)
             ] 

isSym,isStr,isPair,isNum,isBool,sym2str,str2sym :: [Exp] -> ThrowsError Exp

isSym [Symbol _] = return $ Bool True
isSym [other] = return $ Bool False 
isSym badArg = throwError $ NumArgs 1 badArg "symbol?"

isStr [String _] = return $ Bool True
isStr [other] = return $ Bool False 
isStr badArg = throwError $ NumArgs 1 badArg "string?"

isPair [List _] = return $ Bool True
isPair [DotList _ _] = return $ Bool True
isPair [other] = return $ Bool False
isPair badArg = throwError $ NumArgs 1 badArg "pair?"

isBool [Bool _] = return $ Bool True
isBool [other] = return $ Bool False
isBool badArg = throwError $ NumArgs 1 badArg "bool?"

isNum [Integer _] = return $ Bool True
isNum [other] = return $ Bool False
isNum badArg = throwError $ NumArgs 1 badArg "number?"

sym2str [Symbol s] = return $ String s
sym2str [other] = throwError $ TypeMismatch "symbol" other "symbol->string"
sym2str badArg = throwError $ NumArgs 1 badArg "symbol->string"

str2sym [String s] = return $ Symbol s
str2sym [other] = throwError $ TypeMismatch "string" other "string->symbol"
str2sym badArg = throwError $ NumArgs 1 badArg "string->symbol"

eqv :: [Exp] -> ThrowsError Exp
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Integer arg1), (Integer arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Symbol arg1), (Symbol arg2)] = return $ Bool $ arg1 == arg2
eqv [(DotList xs x), (DotList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && 
                                                    (and $ map eqvPair $ zip arg1 arg2)
    where eqvPair (x1, x2) = case eqv [x1, x2] of
                               Left err -> False
                               Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList "eqv"

car :: [Exp] -> ThrowsError Exp
car [List (x:xs)] = return x
car [DotList (x:xs) _] = return x
car [badArg] = throwError $ TypeMismatch "list" badArg "car"
car badArg = throwError $ NumArgs 1 badArg "car"

cdr :: [Exp] -> ThrowsError Exp
cdr [List (x:xs)] = return $ List xs
cdr [DotList (x:[]) last] = return last
cdr [DotList (x:xs) last] = return $ DotList xs last
cdr [badArg] = throwError $ TypeMismatch "list" badArg "cdr"
cdr badArg = throwError $ NumArgs 1 badArg "cdr"

cons :: [Exp] -> ThrowsError Exp
cons [x, List []] = return $ List [x]
cons [x, List xs] = return $ List $ x:xs
cons [x, DotList xs last] = return $ DotList (x:xs) last
cons [x1,x2] = return $ DotList [x1] x2
cons badArg       = throwError $ NumArgs 2 badArg "cons"

quote' :: [Exp] -> ThrowsError Exp
quote' [x] = return $ x
quote' badArg@(x:xs) = throwError $ NumArgs 1 badArg "quote"

escape :: [Exp] -> ThrowsError Exp
escape [String str] = return $ String $ show $ stringToHtml str
escape badArg       = throwError $ NumArgs 1 badArg "escape"

comp :: (Exp -> ThrowsError a) -> (a -> a -> Bool) -> [Exp] -> ThrowsError Exp
comp unpack op (x0:x1:xs) = 
    do {val0 <- unpack x0;
        val1 <- unpack x1;
        if not (val0 `op` val1)
        then return $ Bool False
        else if (length xs == 0) 
             then return (Bool True) 
             else comp unpack op (x1:xs)} -- Does the double evaluation of x1 means some harm?
comp _ _ (x:[]) = throwError $ AtLeastNumArgs 2 [x] "generic-data-unpacker"

compInt :: (Integer -> Integer -> Bool) -> ([Exp] -> ThrowsError Exp)
compInt = comp unpackNum

compStr :: (String -> String -> Bool) -> ([Exp] -> ThrowsError Exp)
compStr = comp unpackStr

numOp :: (Integer -> Integer -> Integer) -> [Exp] -> ThrowsError Exp
numOp op args = mapM unpackNum args >>= return . Integer . foldl1 op

binNumOp :: (Integer -> Integer -> Integer) -> [Exp] -> ThrowsError Exp
binNumOp op xs@(x0:x1:[]) = mapM unpackNum xs >>= return . Integer . foldl1 op
binNumOp op xs            = throwError $ NumArgs 2 xs "numeric comparison"

unpackNum :: Exp -> ThrowsError Integer
unpackNum (Integer int) = return int
unpackNum notNum        = throwError $ TypeMismatch "number" notNum "number-unpacker"

unpackStr :: Exp -> ThrowsError String
unpackStr (String str) = return str
unpackStr notStr       = throwError $ TypeMismatch "string" notStr "string-unpacker"

unpackBool :: Exp -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool "boolean-unpacker"

app :: [Exp] -> ThrowsError Exp
app [List a, List b] = return $ List $ a ++ b
app [DotList a a', DotList b b'] = return $ DotList (a ++ [a'] ++ b) b'
app [DotList a a', List b] = return $ List $ a ++ [a'] ++ b
app [List a, DotList b b'] = return $ DotList (a ++ b) b'
app badArg = throwError $ TypeMismatch "lists" (List badArg) "apply"

conct :: [Exp] -> ThrowsError Exp
conct [String a, String b] = return $ String (a ++ b)
conct badArg = throwError $ TypeMismatch "strings" (List badArg) "concat"

-------------------------------------
-- Salsa IO Primitives
-------------------------------------

ioPrimitives :: [(String, [Exp] -> IOThrowsError Exp)]
ioPrimitives = [("open-input-file", makePort ReadMode)
                ,("open-output-file", makePort WriteMode)
                ,("close-input-port", closePort)
                ,("close-output-port", closePort)
                ,("read", readProc)
                ,("write", writeProc)
                ,("print", putProc)
                ,("read-contents", readContents)
                ,("read-all", readAll)
               ]

makePort :: IOMode -> [Exp] -> IOThrowsError Exp
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode

closePort :: [Exp] -> IOThrowsError Exp
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ Bool False

readProc :: [Exp] -> IOThrowsError Exp
readProc [] = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExp
readProc [String s] = liftThrows $ readExp s

writeProc :: [Exp] -> IOThrowsError Exp
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return obj)

putProc :: [Exp] -> IOThrowsError Exp
putProc [String s] = liftIO $ putStrLn s >> (return $ String s)

readContents :: [Exp] -> IOThrowsError Exp
readContents [String filename] = liftM String $ liftIO $ readFile filename

parseFile :: String -> IOThrowsError [Exp]
parseFile filename = (liftIO $ readFile filename) >>= liftThrows . readExps

readAll :: [Exp] -> IOThrowsError Exp
readAll [String filename] = liftM List $ parseFile filename

